home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1994 / MacHack 1994.toast / MacHack™ 1987-1994 / MacHack™ '92 / Hacks ’92 / ScreenSaver?!!! / MacHack.lisp < prev    next >
Encoding:
Text File  |  1992-06-18  |  5.6 KB  |  193 lines  |  [TEXT/CCL2]
  1. ;;;;ADLM.lisp
  2. ;;;;AfterDark LISP Module written in Macintosh Common LISP.
  3. ;;;;This is the (non-gratuitously) largest AfterDark Module you will ever see.
  4. ;;;;Special thanks to all the people I bugged with idiotic ToolBox questions.
  5.  
  6. (defparameter *min-pts* 10 "Minimum number of points in a region.")
  7. (defparameter *rnd-pts* 10 "Maximum number of additional points in a region.")
  8. (defparameter *sleep-cnt* 1 "Seconds to leave a region inverted.")
  9.  
  10. (defun select-window ()
  11.   "Lets the user pick a window and returns it."
  12.   (car (select-item-from-list (windows)))
  13. )
  14.  
  15. (defun ADLM-black (&optional (port (wptr (select-window))))
  16.   "port
  17. Does not-so-funky screen-saver things to port…paints all of port black."
  18.   (with-port port
  19.     (with-fore-color *black-color*
  20.       (#_FillRgn (rref port :GrafPort.visrgn) *black-pattern*)
  21.   ) )
  22.   (let (start
  23.         where
  24.        )
  25.     (rlet ((loc :long))
  26.       (#_GetMouse loc)
  27.       (setq start (%get-long loc))
  28.       (setq where start)
  29.       (do ()
  30.           ((/= where start) (mouse-down-p))
  31.         (#_GetMouse loc)
  32.         (setq where (%get-long loc))
  33.   ) ) )
  34.   (quit)
  35. )
  36.  
  37. (defun ADLM-random-regions (&optional (port (wptr (select-window))))
  38.   "port
  39. Does funky screen-saver things to port.
  40. Specifically, it uses standard AI-vision edge-detection to find objects in
  41. the port, and then blacks-out/restores randomly selected objects.
  42. All right, so the seedFill and SeedCFill routines don't work.
  43. Go for random regions."
  44.  
  45.   (with-port port
  46.     (let* ((rect (rref port :GrafPort.PortRect))
  47.            (left (rref rect :rect.left))
  48.            (top (rref rect :rect.top))
  49.            (right (rref rect :rect.right))
  50.            (bottom (rref rect :rect.bottom))
  51.            (width (- right left))
  52.            (height (- bottom top))
  53.            (rgn (#_NewRgn))
  54.            mouse-start
  55.            start-h
  56.            start-v
  57.            h
  58.            v
  59.           )
  60.       (unwind-protect
  61.         (rlet ((loc :point))
  62.           (#_GetMouse loc)
  63.           (setq mouse-start (%get-long loc))
  64.           (do* ((mouse-pos (%get-long loc) (%get-long loc)))
  65.                ((or (/= mouse-pos mouse-start) (mouse-down-p)))
  66.             (#_OpenRgn)
  67.             (setq start-h (+ left (random width)))
  68.             (setq start-v (+ top (random height)))
  69.             (#_MoveTo start-h start-v)
  70.             (unwind-protect
  71.               (dotimes (i (+ *min-pts* (random *rnd-pts*)))
  72.                 (setq h (+ left (random width)))
  73.                 (setq v (+ top (random height)))
  74.                 (#_LineTo h v)
  75.               )
  76.               (#_LineTo start-h start-v)
  77.               (#_CloseRgn rgn)
  78.               (unwind-protect
  79.                 (progn
  80.                   (#_InvertRgn rgn)
  81.                   (sleep *sleep-cnt*)
  82.                 )
  83.                 (#_InvertRgn rgn)
  84.                 (#_GetMouse loc)
  85.         ) ) ) )
  86.         (#_DisposeRgn rgn)
  87.   ) ) )
  88.   (quit)
  89. )
  90.  
  91. ;;;;An automatically closing about-win.
  92. (defclass about-win (color-dialog)
  93.   ((time-up
  94.      :documentation "Time it first showed up."
  95.      :accessor time-up
  96.      :initarg :time-up
  97.      :initform (get-universal-time)
  98.      :type 'fixnum
  99.    )
  100.   )
  101.   (:default-initargs
  102.     :window-type :double-edge-box
  103.     :view-position :centered
  104.     :color-p *color-available*
  105. ) )
  106.  
  107. (defmethod window-null-event-handler ((view about-win))
  108.   (when (> (- (get-universal-time) (time-up view)) 30)
  109.     (return-from-modal-dialog nil)
  110. ) )
  111.  
  112. (defmethod initialize-instance :after ((view about-win) &key)
  113.   (apply #'remove-menu-items *apple-menu* (menu-items *apple-menu*))
  114.   (add-menu-items *apple-menu*
  115.     (make-instance 'menu-item
  116.       :menu-item-title "About Me"
  117.       :menu-item-action #'launch
  118.     )
  119.     (make-instance 'menu-item :menu-item-title "-")
  120. ) )
  121.  
  122. (defmethod view-key-event-handler ((view about-win) char)
  123.   (declare (ignore char))
  124.   (return-from-modal-dialog nil)
  125. )
  126.  
  127. ;;;;I can have as many functions as I want to shoot off at startup and
  128. ;;;;shutdown.
  129.  
  130. (defun launch ()
  131.   "This function will be called at launch time."
  132.  
  133.   (modal-dialog
  134.     (make-instance 'about-win
  135.       :view-size #@(400 150)
  136.       :view-subviews
  137.       (list
  138.         (make-instance 'static-text-dialog-item
  139.           :dialog-item-text "This is not quite done, but released."
  140.           :view-position #@(20 20)
  141.           :view-size #@(360 110)
  142.           :view-font '("Helvetica" 40)
  143.           :part-color-list
  144.           (when *color-available*
  145.             (list :text *red-color*)
  146.           )
  147.         )
  148.         (make-instance 'button-dialog-item
  149.           :dialog-item-text "Ok"
  150.           :view-font '("Helvetica" 14 :bold)
  151.           :view-position #@(300 125)
  152.           :view-size #@(70 20)
  153.           :default-button t
  154.           :part-color-list
  155.           (when *color-available*
  156.             (list :text *red-color* :body *blue-color* :frame *green-color*)
  157.           )
  158.           :dialog-item-action
  159.           #'(lambda (button)
  160.               (declare (ignore button))
  161.               (return-from-modal-dialog nil)
  162.             )
  163.         )
  164. ) ) ) )
  165.  
  166. ;;;;full-screen
  167. (defclass full-screen (window)
  168.   ()
  169.   (:default-initargs
  170.     :view-position #@(0 0)
  171.     :view-size (make-point *screen-width* *screen-height*)
  172.     :window-type :single-edge-box
  173. ) )
  174.  
  175. (defmethod view-key-event-handler ((view full-screen) char)
  176.   (declare (ignore char))
  177.   (quit)
  178. )
  179.  
  180. ;;;;screen-saver
  181.  
  182. (defun screen-saver ()
  183.   "I need hide-menubar and some other junk I left at home, 'natch."
  184.   (let ((foo (shift-key-p)))
  185.     (cond
  186.       (foo (ADLM-black (wptr (make-instance 'full-screen))))
  187.       ((null foo) (ADLM-random-regions (wptr (make-instance 'full-screen))))
  188.       (t (quit))
  189. ) ) )
  190.  
  191. (setq *restore-lisp-functions*
  192.       (append *restore-lisp-functions* (list #'launch #'screen-saver))
  193. )